home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / comp / assembler / m68is1.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  12.8 KB  |  385 lines
  1. (herald (assembler m68is1 t 0)
  2.         (env t (assembler as_open)))
  3.  
  4.  
  5. ;;; Procedures for the following instructions do error
  6. ;;; checking but return false instead of erring out when the checks
  7. ;;; fail.  
  8. ;;;
  9. ;;; link, dbcc, scc, swap, tas, trap, unlk, jsr, jmp
  10.  
  11. ;;; The whole way of converting arguments and selecting alternatives 
  12. ;;; is bogus.  A real parser is needed to do the job right.  Blah.
  13.  
  14. ;;; 68000 instruction format
  15. ;;; op-word
  16. ;;; [ imm-word-1 [ imm-word-2 ] ]
  17. ;;; [ src-ext-1  [ src-ext-2  ] ]
  18. ;;; [ dest-ext-1 [ dest-ext-2 ] ]
  19.  
  20. ;;; Size hacking utilities.
  21.  
  22. (define-constant bwl-data  '((b . 0) (w . 1) (l . 2)))
  23. (define (bwl size) (cdr (assq size bwl-data)))
  24. (define (format-bwl bits) (symbol->character (car (rassq bits bwl-data))))
  25.  
  26. (define-constant blw-data  '((b . 1) (w . 3) (l . 2)))
  27. (define (blw size) (cdr (assq size blw-data)))
  28. (define (format-blw bits) (symbol->character (car (rassq bits blw-data))))
  29.  
  30. (define-constant wl-data '((w . 0) (l . 1)))
  31. (define (wl size) (cdr (assq size wl-data)))
  32. (define (format-wl bits) (symbol->character (car (rassq bits wl-data))))
  33.  
  34. (define-constant lw-data '((w . 1) (l . 0)))
  35. (define (lw size) (cdr (assq size lw-data)))
  36. (define (format-lw bits) (symbol->character (car (rassq bits lw-data))))
  37.  
  38. (define (symbol->character symbol)
  39.     (char-downcase (string-head (symbol->string symbol))))
  40.  
  41. (define (format-quick d) (if (fx= d 0) 8 d))   
  42.  
  43. (define (context-bwl bits) (bits->context bits bwl-data))
  44. (define (context-blw bits) (bits->context bits blw-data))
  45. (define (context-wl bits)  (bits->context bits wl-data))
  46. (define (context-lw bits)  (bits->context bits lw-data))
  47.  
  48. (define (bits->context bits data)
  49.     (xcase (car (rassq bits data))
  50.        ((b) '(general  8))
  51.        ((w) '(general 16))
  52.        ((l) '(general 32))))
  53.  
  54. ;;; Random converters
  55. (define (quick? d)
  56.    (cond ((and (fixnum? d) (fx<= d 8) (fx> d 0))
  57.           (if (fx= d 8) 0 d))
  58.          (else nil)))
  59.  
  60. (define (dr-number? frob)
  61.     (cond ((and (fixnum? frob) (fx< frob 8) (fx>= frob 0)) frob)
  62.           ((%dregister? frob) (fg-argref frob 0))
  63.           (else nil)))
  64.  
  65. (define (ar-number? frob)
  66.     (cond ((and (fixnum? frob) (fx< frob 16) (fx>= frob 8)) (fx- frob 8))
  67.           ((%aregister? frob) (fg-argref frob 0))
  68.           (else nil)))
  69.  
  70. (define (ar+-number? frob)
  71.     (cond ((and (fixnum? frob) (fx< frob 16) (fx>= frob 8)) (fx- frob 8))
  72.           ((@a+? frob) (fg-argref frob 0))
  73.           (else nil)))
  74.  
  75. ;;; Category predicates (must return argument if true)
  76.  
  77. ;;; The bits are: data? memory? control? alterable?
  78.  
  79. (define-constant *ea-categories*
  80.     '#(#b1001 #b0001 #b1111 #b1101 #b1101 #b1111 #b1111))  
  81.  
  82. ;;; Return a predicate that checks to see if the given ea
  83. ;;; falls into the categories specified by mask.
  84.  
  85. (define (ea-category-predicate mask)
  86.   (lambda (ea)
  87.     (and (fg? (if (pair? ea) (car ea) ea))
  88.          (let ((fg (if (pair? ea) (car ea) ea)))
  89.            (receive (v1 w1 start2)
  90.                     (destructure-fg fg 0)
  91.               (cond ((fxn= w1 3) (error "expecting an ea, got ~s" ea))
  92.                     ((fx< v1 7)
  93.                      (fx= mask (fixnum-logand (vref *ea-categories* v1) mask)))
  94.                     (else
  95.                      (receive (v2 w2 #f)
  96.                               (destructure-fg fg start2)
  97.                         (cond ((fx= w2 3)
  98.                                (cond ((fx< v2 2) 
  99.                                       t)
  100.                                      ((fx= v2 4) 
  101.                                       (fx= mask (fixnum-logand #b1100 mask)))
  102.                                      (else 
  103.                                       (not (fixnum-odd? mask)))))
  104.                               (else 
  105.                                (error "expecting an ea, got ~s" ea))))))))
  106.          ea)))
  107.  
  108. (define (ea-all? ea)
  109.     (if (fg? (if (pair? ea) (car ea) ea))
  110.         ea 
  111.         nil))
  112.  
  113. (define ea-m&a?  (ea-category-predicate #b0101))
  114. (define ea-d&a?  (ea-category-predicate #b1001))
  115. (define ea-a?    (ea-category-predicate #b0001))
  116. (define ea-d?    (ea-category-predicate #b1000))
  117. (define ea-c?    (ea-category-predicate #b0010))
  118. (define ea-c&a?  (ea-category-predicate #b0011))
  119.  
  120. (define (ea-c&a-or-decr? ea)
  121.     (if (or (ea-c&a? ea) (@-a? ea)) ea nil))
  122.  
  123. (define (ea-c&-or-incr? ea)
  124.     (if (or (ea-c? ea) (@a+? ea)) ea nil))
  125.  
  126. ;;; Some semi-general formats
  127.                     
  128. ;;; Arithmetic op formats
  129.                                       
  130. (define-fg (aop-quick sub? bwl (&-quick? data) (ea-a? dst))
  131.    (local subfg)
  132.    (printer "~aq.~c #~s,~g" 
  133.             (if (fx= 1 (? sub?)) "sub" "add")
  134.             (format-bwl (? bwl)) 
  135.             (format-quick (? data)) 
  136.             (? subfg))
  137.    (0 1 0 1) (f u 3 data) (f u 1 sub?) (f u 2 bwl)
  138.    (fg-named subfg (ea-fg (? dst) (context-bwl (? bwl)))))
  139.  
  140. (define-fg (op-immediate opname opcode bwl (&? data) (ea-d&a? dst))
  141.    (local the-rest)
  142.    (printer "~ai.~c ~g" (? opname) (format-bwl (? bwl)) (? the-rest))
  143.    (f u 8 opcode) (f u 2 bwl) 
  144.    (fg-named the-rest (ea-imm-fg (? dst) (? data) (context-bwl (? bwl)))))
  145.  
  146. (define-fg (op-into-ea opname opcode bwl (dr-number? dn) (ea-m&a? dst))
  147.    (local subfg)
  148.    (printer "~a.~c d~s,~g" (? opname) (format-bwl (? bwl)) (? dn) (? subfg))
  149.    (f u 4 opcode) (f u 3 dn) (1) (f u 2 bwl) 
  150.    (fg-named subfg (ea-fg (? dst) (context-bwl (? bwl)))))
  151.  
  152. ;;; '(&!%"# EOR is almost like OP-INTO-EA
  153.  
  154. (define-fg (op-into-ea-1 opname opcode bwl (dr-number? dn) (ea-d&a? dst))
  155.    (local subfg)
  156.    (printer "~a.~c d~s,~g" (? opname) (format-bwl (? bwl)) (? dn) (? subfg))
  157.    (f u 4 opcode) (f u 3 dn) (1) (f u 2 bwl) 
  158.    (fg-named subfg (ea-fg (? dst) (context-bwl (? bwl)))))
  159.  
  160. (define-fg (op-into-dn opname opcode bwl (ea-all? src) (dr-number? dn))
  161.    (local subfg)
  162.    (printer "~a.~c ~g,d~s" (? opname) (format-bwl (? bwl)) (? subfg) (? dn))
  163.    (f u 4 opcode) (f u 3 dn) (0) (f u 2 bwl) 
  164.    (fg-named subfg (ea-fg (? src) (context-bwl (? bwl)))))
  165.  
  166. (define-fg (op-into-a opname opcode wl (ea-all? src) (ar-number? an))
  167.    (local subfg)
  168.    (printer "~aa.~c ~g,a~s" (? opname) (format-wl (? wl)) (? subfg) (? an))
  169.    (f u 4 opcode) (f u 3 an) (f u 1 wl) (1 1)
  170.    (fg-named subfg (ea-fg (? src) (context-wl (? wl)))))
  171.                                                              
  172. ;;; addx and subx added by RK
  173.  
  174. (define-fg (arith-x/d name op bwl (dr-number? dx) (dr-number? dy))
  175.   (printer "~a.~c d~s,d~s" (? name)
  176.                            (format-bwl (? bwl))
  177.                            (? dx) (? dy))
  178.   (f u 4 op) (f u 3 dx) (1) (f u 2 bwl) (f u 3 0) (f u 3 dy))
  179.  
  180.  
  181.  
  182. ;;; Shift op formats
  183.  
  184. (define (format-dir d)
  185.     (if (fx= d 0) #\r #\l))
  186.  
  187. (define (format-shift op)
  188.     (cond ((fx= op 0) "as")
  189.           ((fx= op 1) "ls")
  190.           ((fx= op 3) "ro")
  191.           ((fx= op 2) "rox")))
  192.                   
  193. (define-fg (shift-op/dd op dir bwl (dr-number? dx) (dr-number? dy))
  194.     (printer "~a~c.~c d~s,d~s" (format-shift (? op)) 
  195.                                (format-dir (? dir)) 
  196.                                (format-bwl (? bwl))
  197.                                (? dx) (? dy))
  198.     (f u 4 #xE) (f u 3 dx) (f u 1 dir) (f u 2 bwl) (1) (f u 2 op) (f u 3 dy))
  199.  
  200. (define-fg (shift-op/id op dir bwl (&-quick? data) (dr-number? dy))
  201.     (printer "~a~c.~c #~s,d~s" (format-shift (? op)) 
  202.                                (format-dir (? dir)) 
  203.                                (format-bwl (? bwl))
  204.                                (format-quick (? data)) (? dy))
  205.     (f u 4 #xE) (f u 3 data) (f u 1 dir) (f u 2 bwl) (0) (f u 2 op) (f u 3 dy))
  206.  
  207. (define-fg (shift-op/e op dir dst)
  208.     (printer "~a~c.w ~g" (format-shift (? op)) 
  209.                          (format-dir (? dir))
  210.                          (? subfg))
  211.     (local subfg)
  212.     (f u 4 #xE) (0) (f u 2 op) (f u 1 dir) (1 1)
  213.     (fg-named subfg (ea-fg (? dst) nil)))
  214.  
  215. ;;; BIT op formats      
  216.  
  217. (define (format-bit-op op)
  218.     (cond ((fx= op 1) "bchg")
  219.           ((fx= op 2) "bclr")
  220.           ((fx= op 3) "bset")
  221.           ((fx= op 0) "btst")))
  222.  
  223. (define-fg (bit-op/de op (dr-number? dn) dst)
  224.     (printer "~a d~s,~g" (format-bit-op (? op)) (? dn) (? subfg))
  225.     (local subfg)
  226.     (0 0 0 0) (f u 3 dn) (1) 
  227.     (f u 2 op)
  228.     (fg-named subfg (ea-fg (? dst) nil)))
  229.  
  230. (define-fg (bit-op/ie op (&-moveq-byte? data) dst)
  231.     (printer "~a #~s,~g" (format-bit-op (? op)) (? data) (? subfg))
  232.     (local subfg)
  233.     (0 0 0 0   1 0 0 0)
  234.     (f u 2 op)
  235.     (fg-named subfg (if (fg? (? dst)) (? dst) (car (? dst))))
  236.     (f u 8 0) (f s 8 data)
  237.     (fg (if (fg? (? dst)) null-fg (cdr (? dst)))))
  238.  
  239. (define-fg (%null-fg) (printer ""))
  240. (define null-fg (%null-fg))
  241.  
  242. ;;; Random format 1 - DIVS DIVU MULS MULU CHK                
  243. (define (op-reg-ea.w opname op1 op2 src dn)
  244.     (or (op-reg-ea.w-1 opname op1 op2 src dn)
  245.         (error "no match for (~a.w ~g ~g)" opname src dn)))
  246.  
  247. (define-fg (op-reg-ea.w-1 opname op1 op2 (ea-d? src) (dr-number? dn))
  248.     (printer "~a.w ~g,d~s" (? opname) (? subfg) (? dn))
  249.     (local subfg)
  250.     (f u 4 op1) (f u 3 dn) (f u 3 op2) 
  251.     (fg-named subfg (ea-fg (? src) '(general 16))))
  252.  
  253. ;;; Random format 2 - NEG NEGX NOT TST CLR
  254. (define (op-size-ea opname op size dst)
  255.     (or (op-size-ea-1 opname op size dst)
  256.         (error "no match for (~a ~s ~g)" opname size dst)))
  257.  
  258. (define-fg (op-size-ea-1 opname op bwl (ea-d&a? dst))
  259.     (printer "~a.~c ~g" (? opname) (format-bwl (? bwl)) (? subfg))
  260.     (local subfg)
  261.     (f u 8 op) (f u 2 bwl) (fg-named subfg (ea-fg (? dst) nil)))
  262.  
  263.  
  264.  
  265. ;;; Branches: BRA, BSR, Bcc
  266.  
  267. (define (m68/jbcc jump-op tag) (branch-op (jump-op->m68-cc jump-op) tag))
  268. (define (m68/jbra tag)         (branch-op 0 tag))
  269. (define (m68/jbsr tag)         (branch-op 1 tag))
  270.  
  271. (define-fg (branch-op cc tag)
  272.   (printer "jb~a    ~g" (format-br (? cc)) (? tag))
  273.   (local dot displ width)
  274.   (mark dot)
  275.   (depending-on (disp dot tag) 
  276.         (choose-a-br (width 0) displ)
  277.         (make-bxx-fg (? cc) (? width) (? displ)))
  278.   )
  279.              
  280. (define (make-bxx-fg cc width displ)
  281.   (let ((displ (fx- displ 16)))
  282.     (xcond ((fx= width  0) null-fg)
  283.        ((fx= width 16) (m68/bxx.s-abs cc (fixnum-ashr displ 3)))
  284.        ((fx= width 32) (m68/bxx.l-abs cc (fixnum-ashr displ 3))))))
  285.  
  286. (define-fg (m68/bxx.s-abs cc displ)
  287.     (printer "b~a ~s" (format-cc (? cc)) (? displ))
  288.     (f u 4 #x6) (f u 4 cc) (f u 8 displ))
  289.  
  290. (define-fg (m68/bxx.l-abs cc displ)
  291.     (printer "b~a ~s" (format-cc (? cc)) (? displ))
  292.     (f u 4 #x6) (f u 4 cc) (f u 8 0) (f u 16 displ))
  293.  
  294. (define (choose-a-br current-width displ)
  295.   (let ((actual-backwards-displ (fx- displ 16)))
  296.     (cond ((fx< actual-backwards-displ -16)
  297.        (cond ((8bit-in-bits? actual-backwards-displ) (return 16 displ))
  298.          ((16bit-in-bits? actual-backwards-displ) (return 32 displ))
  299.          (else (error "32 bit conditional branch"))))
  300.       (else
  301.        (let ((min-forward-displ (fx- displ current-width)))
  302.          (cond ((fx= min-forward-displ 0) 
  303.             (return 0 0))
  304.            ((8bit-in-bits? min-forward-displ) 
  305.             (return 16 (fx+ min-forward-displ 16)))
  306.            ((16bit-in-bits? (fx+ min-forward-displ 16))
  307.             (return 32 (fx+ min-forward-displ 32)))
  308.            (else (error "32 bit conditional branch"))))))))
  309.  
  310.  
  311. ;;; CC formating
  312.  
  313. (let ((data '(("cc" . 4) ("cs" . 5) ("eq" . 7) ("f" . 1) 
  314.               ("ge" . 12) ("gt" . 14) ("hi" . 2) ("le" . 15) 
  315.               ("ls" . 3) ("lt" . 13) ("mi" . 11) ("ne" . 6) 
  316.               ("pl" . 10) ("t" . 0) ("vc" . 8) ("vs" . 9))))
  317.  
  318.    (define (format-br bits)
  319.       (cond ((fx= bits 0) "ra")
  320.             ((fx= bits 1) "sr")
  321.             (else (car (rassq bits data)))))
  322.  
  323.    (define (format-cc bits)
  324.       (car (rassq bits data)))
  325.  
  326.    )
  327.  
  328. (let ((data '((cc . 4) (cs . 5) (eq . 7) (f . 1) 
  329.               (ge . 12) (gt . 14) (hi . 2) (le . 15) 
  330.               (ls . 3) (lt . 13) (mi . 11) (ne . 6) 
  331.               (pl . 10) (t . 0) (vc . 8) (vs . 9))))
  332.  
  333.    (define (m68-cc? cc-symbol)
  334.       (cond ((assq cc-symbol data)
  335.              => cdr)
  336.             (else nil)))
  337.  
  338.    (define (convert-cc cc-symbol)
  339.       (cond ((m68-cc? cc-symbol) => identity)
  340.             (else 
  341.              (error "expecting a 68000 condition code, got ~s" cc-symbol))))
  342.  
  343.    )
  344.  
  345. (define (jump-op->m68-cc cc)
  346.   (cond ((fx< cc 0)
  347.          ;;    '#(abs eq  le  lt   leu ltu neg vs) *JUMP-OPS-NEGATIVE*
  348.          (vref '#(0   7  #xF  #xD  3   5   #xB  9) (fixnum-negate cc)))
  349.         (else 
  350.          ;;    '#(abs neq gt  ge   gtu geu pos vc) *JUMP-OPS-POSITIVE*
  351.          (vref '#(0   6  #xE  #xC  2   4   #xA  8) cc))))
  352.  
  353. ;;;  Labels.   This needs some work.
  354.  
  355. (define (m68/label node)
  356.      (d@pc (data-current-label node)))
  357.  
  358. (define label m68/label)
  359. (define template m68/label)
  360.  
  361. ;;;;-------------------------------
  362.  
  363. ;;; do this right (how?) sometime.  byte, word, long, etc.
  364.  
  365. (define-data-fg (m68/space x)
  366.     (printer ".space  ~s" (? x))
  367.     (f u x 0))
  368.  
  369. ;;; Problem with signed/unsigned
  370.  
  371. (define-data-fg (m68/byte x)
  372.     (printer ".byte   x~x" (? x))
  373.     (f u 8 x))
  374.  
  375. (define-data-fg (m68/word x)
  376.     (printer ".word   x~x" (? x))
  377.     (f u 16 x))
  378.  
  379. ;;; Set machine parameters.
  380.  
  381. (set (machine-template-emitter *m68-machine*) emit-m68-template)
  382. (set (machine-cond-branch      *m68-machine*) m68/jbcc)
  383. (set (machine-uncond-branch    *m68-machine*) m68/jbra)         
  384.  
  385.